home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / format.scm < prev    next >
Text File  |  1999-04-19  |  57KB  |  1,679 lines
  1. ;;; "format.scm" Common LISP text output formatter for SLIB
  2. ; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
  7. ; Please send error reports to the email address above.
  8. ; For documentation see slib.texi and format.doc.
  9. ; For testing load formatst.scm.
  10. ;
  11. ; Version 3.0
  12.  
  13. (provide 'format)
  14. (require 'string-case)
  15. (require 'string-port)
  16. (require 'rev4-optional-procedures)
  17.  
  18. ;;; Configuration ------------------------------------------------------------
  19.  
  20. (define format:symbol-case-conv #f)
  21. ;; Symbols are converted by symbol->string so the case of the printed
  22. ;; symbols is implementation dependent. format:symbol-case-conv is a
  23. ;; one arg closure which is either #f (no conversion), string-upcase!,
  24. ;; string-downcase! or string-capitalize!.
  25.  
  26. (define format:iobj-case-conv #f)
  27. ;; As format:symbol-case-conv but applies for the representation of
  28. ;; implementation internal objects.
  29.  
  30. (define format:expch #\E)
  31. ;; The character prefixing the exponent value in ~e printing.
  32.  
  33. (define format:floats (provided? 'inexact))
  34. ;; Detects if the scheme system implements flonums (see at eof).
  35.  
  36. (define format:complex-numbers (provided? 'complex))
  37. ;; Detects if the scheme system implements complex numbers.
  38.  
  39. (define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
  40. ;; Detects if number->string adds a radix prefix.
  41.  
  42. (define format:ascii-non-printable-charnames
  43.   '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
  44.      "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
  45.      "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
  46.      "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))
  47.  
  48. ;;; End of configuration ----------------------------------------------------
  49.  
  50. (define format:version "3.0")
  51. (define format:port #f)            ; curr. format output port
  52. (define format:output-col 0)        ; curr. format output tty column
  53. (define format:flush-output #f)        ; flush output at end of formatting
  54. (define format:case-conversion #f)
  55. (define format:error-continuation #f)
  56. (define format:args #f)
  57. (define format:pos 0)            ; curr. format string parsing position
  58. (define format:arg-pos 0)        ; curr. format argument position
  59.                     ; this is global for error presentation
  60.  
  61. ; format string and char output routines on format:port
  62.  
  63. (define (format:out-str str)
  64.   (if format:case-conversion
  65.       (display (format:case-conversion str) format:port)
  66.       (display str format:port))
  67.   (set! format:output-col
  68.     (+ format:output-col (string-length str))))
  69.  
  70. (define (format:out-char ch)
  71.   (if format:case-conversion
  72.       (display (format:case-conversion (string ch)) format:port)
  73.       (write-char ch format:port))
  74.   (set! format:output-col
  75.     (if (char=? ch #\newline)
  76.         0
  77.         (+ format:output-col 1))))
  78.  
  79. ;(define (format:out-substr str i n)  ; this allocates a new string
  80. ;  (display (substring str i n) format:port)
  81. ;  (set! format:output-col (+ format:output-col n)))
  82.  
  83. (define (format:out-substr str i n)
  84.   (do ((k i (+ k 1)))
  85.       ((= k n))
  86.     (write-char (string-ref str k) format:port))
  87.   (set! format:output-col (+ format:output-col n)))
  88.  
  89. ;(define (format:out-fill n ch)       ; this allocates a new string
  90. ;  (format:out-str (make-string n ch)))
  91.  
  92. (define (format:out-fill n ch)
  93.   (do ((i 0 (+ i 1)))
  94.       ((= i n))
  95.     (write-char ch format:port))
  96.   (set! format:output-col (+ format:output-col n)))
  97.  
  98. ; format's user error handler
  99.  
  100. (define (format:error . args)        ; never returns!
  101.   (let ((error-continuation format:error-continuation)
  102.     (format-args format:args)
  103.     (port (current-error-port)))
  104.     (set! format:error format:intern-error)
  105.     (if (and (>= (length format:args) 2)
  106.          (string? (cadr format:args)))
  107.     (let ((format-string (cadr format-args)))
  108.       (if (not (zero? format:arg-pos))
  109.           (set! format:arg-pos (- format:arg-pos 1)))
  110.       (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
  111.                                   ~{~a ~}===>~{~a ~})~%        "
  112.           (car format:args)
  113.           (substring format-string 0 format:pos)
  114.           (substring format-string format:pos
  115.                  (string-length format-string))
  116.           (list-head (cddr format:args) format:arg-pos)
  117.           (list-tail (cddr format:args) format:arg-pos)))
  118.     (format port 
  119.         "~%FORMAT: error with call: (format~{ ~a~})~%        "
  120.         format:args))
  121.     (apply format port args)
  122.     (newline port)
  123.     (set! format:error format:error-save)
  124.     (set! format:error-continuation error-continuation)
  125.     (format:abort)
  126.     (format:intern-error "format:abort does not jump to toplevel!")))
  127.  
  128. (define format:error-save format:error)
  129.  
  130. (define (format:intern-error . args)   ;if something goes wrong in format:error
  131.   (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
  132.   (display "        format args: ") (write format:args) (newline)
  133.   (display "        error args:  ") (write args) (newline)
  134.   (set! format:error format:error-save)
  135.   (format:abort))
  136.  
  137. (define (format:format . args)        ; the formatter entry
  138.   (set! format:args args)
  139.   (set! format:arg-pos 0)
  140.   (set! format:pos 0)
  141.   (if (< (length args) 1)
  142.       (format:error "not enough arguments"))
  143.   (let ((destination (car args))
  144.     (arglist (cdr args)))
  145.     (cond
  146.      ((or (and (boolean? destination)    ; port output
  147.            destination)
  148.       (output-port? destination)
  149.       (number? destination))
  150.       (format:out (cond
  151.            ((boolean? destination) (current-output-port))
  152.            ((output-port? destination) destination)
  153.            ((number? destination) (current-error-port)))
  154.           (car arglist) (cdr arglist)))
  155.      ((and (boolean? destination)    ; string output
  156.        (not destination))
  157.       (call-with-output-string
  158.        (lambda (port) (format:out port (car arglist) (cdr arglist)))))
  159.      ((string? destination)        ; dest. is format string (Scheme->C)
  160.       (call-with-output-string
  161.        (lambda (port)
  162.      (format:out port destination arglist))))
  163.      (else
  164.       (format:error "illegal destination `~a'" destination)))))
  165.  
  166. (define (format:out port fmt args)    ; the output handler for a port
  167.   (set! format:port port)        ; global port for output routines
  168.   (set! format:case-conversion #f)    ; modifier case conversion procedure
  169.   (set! format:flush-output #f)        ; ~! reset
  170.   (let ((arg-pos (format:format-work fmt args))
  171.     (arg-len (length args)))
  172.     (cond
  173.      ((< arg-pos arg-len)
  174.       (set! format:arg-pos (+ arg-pos 1))
  175.       (set! format:pos (string-length fmt))
  176.       (format:error "~a superfluous argument~:p" (- arg-len arg-pos)))
  177.      ((> arg-pos arg-len)
  178.       (set! format:arg-pos (+ arg-len 1))
  179.       (display format:arg-pos)
  180.       (format:error "~a missing argument~:p" (- arg-pos arg-len)))
  181.      (else
  182.       (if format:flush-output (force-output port))
  183.       #t))))
  184.  
  185. (define format:parameter-characters
  186.   '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
  187.  
  188. (define (format:format-work format-string arglist) ; does the formatting work
  189.   (letrec
  190.       ((format-string-len (string-length format-string))
  191.        (arg-pos 0)            ; argument position in arglist
  192.        (arg-len (length arglist))    ; number of arguments
  193.        (modifier #f)            ; 'colon | 'at | 'colon-at | #f
  194.        (params '())            ; directive parameter list
  195.        (param-value-found #f)        ; a directive parameter value found
  196.        (conditional-nest 0)        ; conditional nesting level
  197.        (clause-pos 0)            ; last cond. clause beginning char pos
  198.        (clause-default #f)        ; conditional default clause string
  199.        (clauses '())            ; conditional clause string list
  200.        (conditional-type #f)        ; reflects the contional modifiers
  201.        (conditional-arg #f)        ; argument to apply the conditional
  202.        (iteration-nest 0)        ; iteration nesting level
  203.        (iteration-pos 0)        ; iteration string beginning char pos
  204.        (iteration-type #f)        ; reflects the iteration modifiers
  205.        (max-iterations #f)        ; maximum number of iterations
  206.        (recursive-pos-save format:pos)
  207.  
  208.        (next-char            ; gets the next char from format-string
  209.     (lambda ()
  210.       (let ((ch (peek-next-char)))
  211.         (set! format:pos (+ 1 format:pos))
  212.         ch)))
  213.  
  214.        (peek-next-char
  215.     (lambda ()
  216.       (if (>= format:pos format-string-len)
  217.           (format:error "illegal format string")
  218.           (string-ref format-string format:pos))))
  219.  
  220.        (one-positive-integer?
  221.     (lambda (params)
  222.       (cond
  223.        ((null? params) #f)
  224.        ((and (integer? (car params))
  225.          (>= (car params) 0)
  226.          (= (length params) 1)) #t)
  227.        (else (format:error "one positive integer parameter expected")))))
  228.  
  229.        (next-arg
  230.     (lambda ()
  231.       (if (>= arg-pos arg-len)
  232.           (begin
  233.         (set! format:arg-pos (+ arg-len 1))
  234.         (format:error "missing argument(s)")))
  235.       (add-arg-pos 1)
  236.       (list-ref arglist (- arg-pos 1))))
  237.  
  238.        (prev-arg
  239.     (lambda ()
  240.       (add-arg-pos -1)
  241.       (if (negative? arg-pos)
  242.           (format:error "missing backward argument(s)"))
  243.       (list-ref arglist arg-pos)))
  244.  
  245.        (rest-args
  246.     (lambda ()
  247.       (let loop ((l arglist) (k arg-pos)) ; list-tail definition
  248.         (if (= k 0) l (loop (cdr l) (- k 1))))))
  249.  
  250.        (add-arg-pos
  251.     (lambda (n) 
  252.       (set! arg-pos (+ n arg-pos))
  253.       (set! format:arg-pos arg-pos)))
  254.  
  255.        (anychar-dispatch        ; dispatches the format-string
  256.     (lambda ()
  257.       (if (>= format:pos format-string-len)
  258.           arg-pos            ; used for ~? continuance
  259.           (let ((char (next-char)))
  260.         (cond
  261.          ((char=? char #\~)
  262.           (set! modifier #f)
  263.           (set! params '())
  264.           (set! param-value-found #f)
  265.           (tilde-dispatch))
  266.          (else
  267.           (if (and (zero? conditional-nest)
  268.                (zero? iteration-nest))
  269.               (format:out-char char))
  270.           (anychar-dispatch)))))))
  271.  
  272.        (tilde-dispatch
  273.     (lambda ()
  274.       (cond
  275.        ((>= format:pos format-string-len)
  276.         (format:out-str "~")    ; tilde at end of string is just output
  277.         arg-pos)            ; used for ~? continuance
  278.        ((and (or (zero? conditional-nest)
  279.              (memv (peek-next-char) ; find conditional directives
  280.                (append '(#\[ #\] #\; #\: #\@ #\^)
  281.                    format:parameter-characters)))
  282.          (or (zero? iteration-nest)
  283.              (memv (peek-next-char) ; find iteration directives
  284.                (append '(#\{ #\} #\: #\@ #\^)
  285.                    format:parameter-characters))))
  286.         (case (char-upcase (next-char))
  287.  
  288.           ;; format directives
  289.  
  290.           ((#\A)            ; Any -- for humans
  291.            (set! format:read-proof (memq modifier '(colon colon-at)))
  292.            (format:out-obj-padded (memq modifier '(at colon-at))
  293.                       (next-arg) #f params)
  294.            (anychar-dispatch))
  295.           ((#\S)            ; Slashified -- for parsers
  296.            (set! format:read-proof (memq modifier '(colon colon-at)))
  297.            (format:out-obj-padded (memq modifier '(at colon-at))
  298.                       (next-arg) #t params)
  299.            (anychar-dispatch))
  300.           ((#\D)            ; Decimal
  301.            (format:out-num-padded modifier (next-arg) params 10)
  302.            (anychar-dispatch))
  303.           ((#\X)            ; Hexadecimal
  304.            (format:out-num-padded modifier (next-arg) params 16)
  305.            (anychar-dispatch))
  306.           ((#\O)            ; Octal
  307.            (format:out-num-padded modifier (next-arg) params 8)
  308.            (anychar-dispatch))
  309.           ((#\B)            ; Binary
  310.            (format:out-num-padded modifier (next-arg) params 2)
  311.            (anychar-dispatch))
  312.           ((#\R)
  313.            (if (null? params)
  314.            (format:out-obj-padded ; Roman, cardinal, ordinal numerals
  315.             #f
  316.             ((case modifier
  317.                ((at) format:num->roman)
  318.                ((colon-at) format:num->old-roman)
  319.                ((colon) format:num->ordinal)
  320.                (else format:num->cardinal))
  321.              (next-arg))
  322.             #f params)
  323.            (format:out-num-padded ; any Radix
  324.             modifier (next-arg) (cdr params) (car params)))
  325.            (anychar-dispatch))
  326.           ((#\F)            ; Fixed-format floating-point
  327.            (if format:floats
  328.            (format:out-fixed modifier (next-arg) params)
  329.            (format:out-str (number->string (next-arg))))
  330.            (anychar-dispatch))
  331.           ((#\E)            ; Exponential floating-point
  332.            (if format:floats
  333.            (format:out-expon modifier (next-arg) params)
  334.            (format:out-str (number->string (next-arg))))
  335.            (anychar-dispatch))
  336.           ((#\G)            ; General floating-point
  337.            (if format:floats
  338.            (format:out-general modifier (next-arg) params)
  339.            (format:out-str (number->string (next-arg))))
  340.            (anychar-dispatch))
  341.           ((#\$)            ; Dollars floating-point
  342.            (if format:floats
  343.            (format:out-dollar modifier (next-arg) params)
  344.            (format:out-str (number->string (next-arg))))
  345.            (anychar-dispatch))
  346.           ((#\I)            ; Complex numbers
  347.            (if (not format:complex-numbers)
  348.            (format:error
  349.             "complex numbers not supported by this scheme system"))
  350.            (let ((z (next-arg)))
  351.          (if (not (complex? z))
  352.              (format:error "argument not a complex number"))
  353.          (format:out-fixed modifier (real-part z) params)
  354.          (format:out-fixed 'at (imag-part z) params)
  355.          (format:out-char #\i))
  356.            (anychar-dispatch))
  357.           ((#\C)            ; Character
  358.            (let ((ch (if (one-positive-integer? params)
  359.                  (integer->char (car params))
  360.                  (next-arg))))
  361.          (if (not (char? ch)) (format:error "~~c expects a character"))
  362.          (case modifier
  363.            ((at)
  364.             (format:out-str (format:char->str ch)))
  365.            ((colon)
  366.             (let ((c (char->integer ch)))
  367.               (if (< c 0)
  368.               (set! c (+ c 256))) ; compensate complement impl.
  369.               (cond
  370.                ((< c #x20)    ; assumes that control chars are < #x20
  371.             (format:out-char #\^)
  372.             (format:out-char
  373.              (integer->char (+ c #x40))))
  374.                ((>= c #x7f)
  375.             (format:out-str "#\\")
  376.             (format:out-str
  377.              (if format:radix-pref
  378.                  (let ((s (number->string c 8)))
  379.                    (substring s 2 (string-length s)))
  380.                  (number->string c 8))))
  381.                (else
  382.             (format:out-char ch)))))
  383.            (else (format:out-char ch))))
  384.            (anychar-dispatch))
  385.           ((#\P)            ; Plural
  386.            (if (memq modifier '(colon colon-at))
  387.            (prev-arg))
  388.            (let ((arg (next-arg)))
  389.          (if (not (number? arg))
  390.              (format:error "~~p expects a number argument"))
  391.          (if (= arg 1)
  392.              (if (memq modifier '(at colon-at))
  393.              (format:out-char #\y))
  394.              (if (memq modifier '(at colon-at))
  395.              (format:out-str "ies")
  396.              (format:out-char #\s))))
  397.            (anychar-dispatch))
  398.           ((#\~)            ; Tilde
  399.            (if (one-positive-integer? params)
  400.            (format:out-fill (car params) #\~)
  401.            (format:out-char #\~))
  402.            (anychar-dispatch))
  403.           ((#\%)            ; Newline
  404.            (if (one-positive-integer? params)
  405.            (format:out-fill (car params) #\newline)
  406.            (format:out-char #\newline))
  407.            (set! format:output-col 0)
  408.            (anychar-dispatch))
  409.           ((#\&)            ; Fresh line
  410.            (if (one-positive-integer? params)
  411.            (begin
  412.              (if (> (car params) 0)
  413.              (format:out-fill (- (car params)
  414.                          (if (> format:output-col 0) 0 1))
  415.                       #\newline))
  416.              (set! format:output-col 0))
  417.            (if (> format:output-col 0)
  418.                (format:out-char #\newline)))
  419.            (anychar-dispatch))
  420.           ((#\_)            ; Space character
  421.            (if (one-positive-integer? params)
  422.            (format:out-fill (car params) #\space)
  423.            (format:out-char #\space))
  424.            (anychar-dispatch))
  425.           ((#\/)            ; Tabulator character
  426.            (if (one-positive-integer? params)
  427.            (format:out-fill (car params) slib:tab)
  428.            (format:out-char slib:tab))
  429.            (anychar-dispatch))
  430.           ((#\|)            ; Page seperator
  431.            (if (one-positive-integer? params)
  432.            (format:out-fill (car params) slib:form-feed)
  433.            (format:out-char slib:form-feed))
  434.            (set! format:output-col 0)
  435.            (anychar-dispatch))
  436.           ((#\T)            ; Tabulate
  437.            (format:tabulate modifier params)
  438.            (anychar-dispatch))
  439.           ((#\Y)            ; Pretty-print
  440.            (require 'pretty-print)
  441.            (pretty-print (next-arg) format:port)
  442.            (set! format:output-col 0)
  443.            (anychar-dispatch))
  444.           ((#\? #\K)        ; Indirection (is "~K" in T-Scheme)
  445.            (cond
  446.         ((memq modifier '(colon colon-at))
  447.          (format:error "illegal modifier in ~~?"))
  448.         ((eq? modifier 'at)
  449.          (let* ((frmt (next-arg))
  450.             (args (rest-args)))
  451.            (add-arg-pos (format:format-work frmt args))))
  452.         (else
  453.          (let* ((frmt (next-arg))
  454.             (args (next-arg)))
  455.            (format:format-work frmt args))))
  456.            (anychar-dispatch))
  457.           ((#\!)            ; Flush output
  458.            (set! format:flush-output #t)
  459.            (anychar-dispatch))
  460.           ((#\newline)        ; Continuation lines
  461.            (if (eq? modifier 'at)
  462.            (format:out-char #\newline))
  463.            (if (< format:pos format-string-len)
  464.            (do ((ch (peek-next-char) (peek-next-char)))
  465.                ((or (not (char-whitespace? ch))
  466.                 (= format:pos (- format-string-len 1))))
  467.              (if (eq? modifier 'colon)
  468.              (format:out-char (next-char))
  469.              (next-char))))
  470.            (anychar-dispatch))
  471.           ((#\*)            ; Argument jumping
  472.            (case modifier
  473.          ((colon)        ; jump backwards
  474.           (if (one-positive-integer? params)
  475.               (do ((i 0 (+ i 1)))
  476.               ((= i (car params)))
  477.             (prev-arg))
  478.               (prev-arg)))
  479.          ((at)            ; jump absolute
  480.           (set! arg-pos (if (one-positive-integer? params)
  481.                     (car params) 0)))
  482.          ((colon-at)
  483.           (format:error "illegal modifier `:@' in ~~* directive"))
  484.          (else            ; jump forward
  485.           (if (one-positive-integer? params)
  486.               (do ((i 0 (+ i 1)))
  487.               ((= i (car params)))
  488.             (next-arg))
  489.               (next-arg))))
  490.            (anychar-dispatch))
  491.           ((#\()            ; Case conversion begin
  492.            (set! format:case-conversion
  493.              (case modifier
  494.                ((at) string-capitalize-first)
  495.                ((colon) string-capitalize)
  496.                ((colon-at) string-upcase)
  497.                (else string-downcase)))
  498.            (anychar-dispatch))
  499.           ((#\))            ; Case conversion end
  500.            (if (not format:case-conversion)
  501.            (format:error "missing ~~("))
  502.            (set! format:case-conversion #f)
  503.            (anychar-dispatch))
  504.           ((#\[)            ; Conditional begin
  505.            (set! conditional-nest (+ conditional-nest 1))
  506.            (cond
  507.         ((= conditional-nest 1)
  508.          (set! clause-pos format:pos)
  509.          (set! clause-default #f)
  510.          (set! clauses '())
  511.          (set! conditional-type
  512.                (case modifier
  513.              ((at) 'if-then)
  514.              ((colon) 'if-else-then)
  515.              ((colon-at) (format:error "illegal modifier in ~~["))
  516.              (else 'num-case)))
  517.          (set! conditional-arg
  518.                (if (one-positive-integer? params)
  519.                (car params)
  520.                (next-arg)))))
  521.            (anychar-dispatch))
  522.           ((#\;)                    ; Conditional separator
  523.            (if (zero? conditional-nest)
  524.            (format:error "~~; not in ~~[~~] conditional"))
  525.            (if (not (null? params))
  526.            (format:error "no parameter allowed in ~~;"))
  527.            (if (= conditional-nest 1)
  528.            (let ((clause-str
  529.               (cond
  530.                ((eq? modifier 'colon)
  531.                 (set! clause-default #t)
  532.                 (substring format-string clause-pos 
  533.                        (- format:pos 3)))
  534.                ((memq modifier '(at colon-at))
  535.                 (format:error "illegal modifier in ~~;"))
  536.                (else
  537.                 (substring format-string clause-pos
  538.                        (- format:pos 2))))))
  539.              (set! clauses (append clauses (list clause-str)))
  540.              (set! clause-pos format:pos)))
  541.            (anychar-dispatch))
  542.           ((#\])            ; Conditional end
  543.            (if (zero? conditional-nest) (format:error "missing ~~["))
  544.            (set! conditional-nest (- conditional-nest 1))
  545.            (if modifier
  546.            (format:error "no modifier allowed in ~~]"))
  547.            (if (not (null? params))
  548.            (format:error "no parameter allowed in ~~]"))
  549.            (cond
  550.         ((zero? conditional-nest)
  551.          (let ((clause-str (substring format-string clause-pos
  552.                           (- format:pos 2))))
  553.            (if clause-default
  554.                (set! clause-default clause-str)
  555.                (set! clauses (append clauses (list clause-str)))))
  556.          (case conditional-type
  557.            ((if-then)
  558.             (if conditional-arg
  559.             (format:format-work (car clauses)
  560.                         (list conditional-arg))))
  561.            ((if-else-then)
  562.             (add-arg-pos
  563.              (format:format-work (if conditional-arg
  564.                          (cadr clauses)
  565.                          (car clauses))
  566.                      (rest-args))))
  567.            ((num-case)
  568.             (if (or (not (integer? conditional-arg))
  569.                 (< conditional-arg 0))
  570.             (format:error "argument not a positive integer"))
  571.             (if (not (and (>= conditional-arg (length clauses))
  572.                   (not clause-default)))
  573.             (add-arg-pos
  574.              (format:format-work
  575.               (if (>= conditional-arg (length clauses))
  576.                   clause-default
  577.                   (list-ref clauses conditional-arg))
  578.               (rest-args))))))))
  579.            (anychar-dispatch))
  580.           ((#\{)            ; Iteration begin
  581.            (set! iteration-nest (+ iteration-nest 1))
  582.            (cond
  583.         ((= iteration-nest 1)
  584.          (set! iteration-pos format:pos)
  585.          (set! iteration-type
  586.                (case modifier
  587.              ((at) 'rest-args)
  588.              ((colon) 'sublists)
  589.              ((colon-at) 'rest-sublists)
  590.              (else 'list)))
  591.          (set! max-iterations (if (one-positive-integer? params)
  592.                      (car params) #f))))
  593.            (anychar-dispatch))
  594.           ((#\})            ; Iteration end
  595.            (if (zero? iteration-nest) (format:error "missing ~~{"))
  596.            (set! iteration-nest (- iteration-nest 1))
  597.            (case modifier
  598.          ((colon)
  599.           (if (not max-iterations) (set! max-iterations 1)))
  600.          ((colon-at at) (format:error "illegal modifier"))
  601.          (else (if (not max-iterations) (set! max-iterations 100))))
  602.            (if (not (null? params))
  603.            (format:error "no parameters allowed in ~~}"))
  604.            (if (zero? iteration-nest)
  605.          (let ((iteration-str
  606.             (substring format-string iteration-pos
  607.                    (- format:pos (if modifier 3 2)))))
  608.            (if (string=? iteration-str "")
  609.                (set! iteration-str (next-arg)))
  610.            (case iteration-type
  611.              ((list)
  612.               (let ((args (next-arg))
  613.                 (args-len 0))
  614.             (if (not (list? args))
  615.                 (format:error "expected a list argument"))
  616.             (set! args-len (length args))
  617.             (do ((arg-pos 0 (+ arg-pos
  618.                        (format:format-work
  619.                         iteration-str
  620.                         (list-tail args arg-pos))))
  621.                  (i 0 (+ i 1)))
  622.                 ((or (>= arg-pos args-len)
  623.                  (>= i max-iterations))))))
  624.              ((sublists)
  625.               (let ((args (next-arg))
  626.                 (args-len 0))
  627.             (if (not (list? args))
  628.                 (format:error "expected a list argument"))
  629.             (set! args-len (length args))
  630.             (do ((arg-pos 0 (+ arg-pos 1)))
  631.                 ((or (>= arg-pos args-len)
  632.                  (>= arg-pos max-iterations)))
  633.               (let ((sublist (list-ref args arg-pos)))
  634.                 (if (not (list? sublist))
  635.                 (format:error
  636.                  "expected a list of lists argument"))
  637.                 (format:format-work iteration-str sublist)))))
  638.              ((rest-args)
  639.               (let* ((args (rest-args))
  640.                  (args-len (length args))
  641.                  (usedup-args
  642.                   (do ((arg-pos 0 (+ arg-pos
  643.                          (format:format-work
  644.                           iteration-str
  645.                           (list-tail
  646.                            args arg-pos))))
  647.                    (i 0 (+ i 1)))
  648.                   ((or (>= arg-pos args-len)
  649.                        (>= i max-iterations))
  650.                    arg-pos))))
  651.             (add-arg-pos usedup-args)))
  652.              ((rest-sublists)
  653.               (let* ((args (rest-args))
  654.                  (args-len (length args))
  655.                  (usedup-args
  656.                   (do ((arg-pos 0 (+ arg-pos 1)))
  657.                   ((or (>= arg-pos args-len)
  658.                        (>= arg-pos max-iterations))
  659.                    arg-pos)
  660.                 (let ((sublist (list-ref args arg-pos)))
  661.                   (if (not (list? sublist))
  662.                       (format:error "expected list arguments"))
  663.                   (format:format-work iteration-str sublist)))))
  664.             (add-arg-pos usedup-args)))
  665.              (else (format:error "internal error in ~~}")))))
  666.            (anychar-dispatch))
  667.           ((#\^)            ; Up and out
  668.            (let* ((continue
  669.                (cond
  670.             ((not (null? params))
  671.              (not
  672.               (case (length params)
  673.                ((1) (zero? (car params)))
  674.                ((2) (= (list-ref params 0) (list-ref params 1)))
  675.                ((3) (<= (list-ref params 0)
  676.                     (list-ref params 1)
  677.                     (list-ref params 2)))
  678.                (else (format:error "too much parameters")))))
  679.             (format:case-conversion ; if conversion stop conversion
  680.              (set! format:case-conversion string-copy) #t)
  681.             ((= iteration-nest 1) #t)
  682.             ((= conditional-nest 1) #t)
  683.             ((>= arg-pos arg-len)
  684.              (set! format:pos format-string-len) #f)
  685.             (else #t))))
  686.          (if continue
  687.              (anychar-dispatch))))
  688.  
  689.           ;; format directive modifiers and parameters
  690.  
  691.           ((#\@)            ; `@' modifier
  692.            (if (eq? modifier 'colon-at)
  693.            (format:error "double `@' modifier"))
  694.            (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
  695.            (tilde-dispatch))
  696.           ((#\:)            ; `:' modifier
  697.            (if modifier (format:error "illegal `:' modifier position"))
  698.            (set! modifier 'colon)
  699.            (tilde-dispatch))
  700.           ((#\')            ; Character parameter
  701.            (if modifier (format:error "misplaced modifier"))
  702.            (set! params (append params (list (char->integer (next-char)))))
  703.            (set! param-value-found #t)
  704.            (tilde-dispatch))
  705.           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
  706.            (if modifier (format:error "misplaced modifier"))
  707.            (let ((num-str-beg (- format:pos 1))
  708.              (num-str-end format:pos))
  709.          (do ((ch (peek-next-char) (peek-next-char)))
  710.              ((not (char-numeric? ch)))
  711.            (next-char)
  712.            (set! num-str-end (+ 1 num-str-end)))
  713.          (set! params
  714.                (append params
  715.                    (list (string->number
  716.                       (substring format-string
  717.                          num-str-beg
  718.                          num-str-end))))))
  719.            (set! param-value-found #t)
  720.            (tilde-dispatch))
  721.           ((#\V)            ; Variable parameter from next argum.
  722.            (if modifier (format:error "misplaced modifier"))
  723.            (set! params (append params (list (next-arg))))
  724.            (set! param-value-found #t)
  725.            (tilde-dispatch))
  726.           ((#\#)            ; Parameter is number of remaining args
  727.            (if modifier (format:error "misplaced modifier"))
  728.            (set! params (append params (list (length (rest-args)))))
  729.            (set! param-value-found #t)
  730.            (tilde-dispatch))
  731.           ((#\,)            ; Parameter separators
  732.            (if modifier (format:error "misplaced modifier"))
  733.            (if (not param-value-found)
  734.            (set! params (append params '(#f)))) ; append empty paramtr
  735.            (set! param-value-found #f)
  736.            (tilde-dispatch))
  737.           ((#\Q)            ; Inquiry messages
  738.            (if (eq? modifier 'colon)
  739.            (format:out-str format:version)
  740.            (let ((nl (string #\newline)))
  741.              (format:out-str
  742.               (string-append
  743.                "SLIB Common LISP format version " format:version nl
  744.                "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
  745.                "  please send bug reports to `lutzeb@cs.tu-berlin.de'"
  746.                nl))))
  747.            (anychar-dispatch))
  748.           (else            ; Unknown tilde directive
  749.            (format:error "unknown control character `~c'"
  750.               (string-ref format-string (- format:pos 1))))))
  751.        (else (anychar-dispatch)))))) ; in case of conditional
  752.  
  753.     (set! format:pos 0)
  754.     (set! format:arg-pos 0)
  755.     (anychar-dispatch)            ; start the formatting
  756.     (set! format:pos recursive-pos-save)
  757.     arg-pos))                ; return the position in the arg. list
  758.  
  759. ;; format:obj->str returns a R4RS representation as a string of an arbitrary
  760. ;; scheme object.
  761. ;; First parameter is the object, second parameter is a boolean if the
  762. ;; representation should be slashified as `write' does.
  763. ;; It uses format:char->str which converts a character into
  764. ;; a slashified string as `write' does and which is implementation dependent.
  765. ;; It uses format:iobj->str to print out internal objects as
  766. ;; quoted strings so that the output can always be processed by (read)
  767.  
  768. (define (format:obj->str obj slashify)
  769.   (cond
  770.    ((string? obj)
  771.     (if slashify
  772.     (let ((obj-len (string-length obj)))
  773.       (string-append
  774.        "\""
  775.        (let loop ((i 0) (j 0))    ; taken from Marc Feeley's pp.scm
  776.          (if (= j obj-len)
  777.          (string-append (substring obj i j) "\"")
  778.          (let ((c (string-ref obj j)))
  779.            (if (or (char=? c #\\)
  780.                (char=? c #\"))
  781.                (string-append (substring obj i j) "\\"
  782.                       (loop j (+ j 1)))
  783.                (loop i (+ j 1))))))))
  784.     obj))
  785.    
  786.    ((boolean? obj) (if obj "#t" "#f"))
  787.    
  788.    ((number? obj) (number->string obj))
  789.  
  790.    ((symbol? obj) 
  791.     (if format:symbol-case-conv
  792.     (format:symbol-case-conv (symbol->string obj))
  793.     (symbol->string obj)))
  794.    
  795.    ((char? obj)
  796.     (if slashify
  797.     (format:char->str obj)
  798.     (string obj)))
  799.    
  800.    ((null? obj) "()")
  801.  
  802.    ((input-port? obj)
  803.     (format:iobj->str obj))
  804.    
  805.    ((output-port? obj)
  806.     (format:iobj->str obj))
  807.      
  808.    ((list? obj)
  809.     (string-append "("
  810.            (let loop ((obj-list obj))
  811.              (if (null? (cdr obj-list))
  812.              (format:obj->str (car obj-list) #t)
  813.              (string-append
  814.               (format:obj->str (car obj-list) #t)
  815.               " "
  816.               (loop (cdr obj-list)))))
  817.            ")"))
  818.  
  819.    ((pair? obj)
  820.     (string-append "("
  821.            (format:obj->str (car obj) #t)
  822.            " . "
  823.            (format:obj->str (cdr obj) #t)
  824.            ")"))
  825.    
  826.    ((vector? obj)
  827.     (string-append "#" (format:obj->str (vector->list obj) #t)))
  828.  
  829.    (else                ; only objects with an #<...> 
  830.     (format:iobj->str obj))))        ; representation should fall in here
  831.  
  832. ;; format:iobj->str reveals the implementation dependent representation of 
  833. ;; #<...> objects with the use of display and call-with-output-string.
  834. ;; If format:read-proof is set to #t the resulting string is additionally 
  835. ;; set into string quotes.
  836.  
  837. (define format:read-proof #f)
  838.  
  839. (define (format:iobj->str iobj)
  840.   (if (or format:read-proof
  841.       format:iobj-case-conv)
  842.       (string-append 
  843.        (if format:read-proof "\"" "")
  844.        (if format:iobj-case-conv
  845.        (format:iobj-case-conv
  846.         (call-with-output-string (lambda (p) (display iobj p))))
  847.        (call-with-output-string (lambda (p) (display iobj p))))
  848.        (if format:read-proof "\"" ""))
  849.       (call-with-output-string (lambda (p) (display iobj p)))))
  850.  
  851.  
  852. ;; format:char->str converts a character into a slashified string as
  853. ;; done by `write'. The procedure is dependent on the integer
  854. ;; representation of characters and assumes a character number according to
  855. ;; the ASCII character set.
  856.  
  857. (define (format:char->str ch)
  858.   (let ((int-rep (char->integer ch)))
  859.     (if (< int-rep 0)            ; if chars are [-128...+127]
  860.     (set! int-rep (+ int-rep 256)))
  861.     (string-append
  862.      "#\\"
  863.      (cond
  864.       ((char=? ch #\newline) "newline")
  865.       ((and (>= int-rep 0) (<= int-rep 32))
  866.        (vector-ref format:ascii-non-printable-charnames int-rep))
  867.       ((= int-rep 127) "del")
  868.       ((>= int-rep 128)        ; octal representation
  869.        (if format:radix-pref
  870.        (let ((s (number->string int-rep 8)))
  871.          (substring s 2 (string-length s)))
  872.        (number->string int-rep 8)))
  873.       (else (string ch))))))
  874.  
  875. (define format:space-ch (char->integer #\space))
  876. (define format:zero-ch (char->integer #\0))
  877.  
  878. (define (format:par pars length index default name)
  879.   (if (> length index)
  880.       (let ((par (list-ref pars index)))
  881.     (if par
  882.         (if name
  883.         (if (< par 0)
  884.             (format:error 
  885.              "~s parameter must be a positive integer" name)
  886.             par)
  887.         par)
  888.         default))
  889.       default))
  890.  
  891. (define (format:out-obj-padded pad-left obj slashify pars)
  892.   (if (null? pars)
  893.       (format:out-str (format:obj->str obj slashify))
  894.       (let ((l (length pars)))
  895.     (let ((mincol (format:par pars l 0 0 "mincol"))
  896.           (colinc (format:par pars l 1 1 "colinc"))
  897.           (minpad (format:par pars l 2 0 "minpad"))
  898.           (padchar (integer->char
  899.             (format:par pars l 3 format:space-ch #f)))
  900.           (objstr (format:obj->str obj slashify)))
  901.       (if (not pad-left)
  902.           (format:out-str objstr))
  903.       (do ((objstr-len (string-length objstr))
  904.            (i minpad (+ i colinc)))
  905.           ((>= (+ objstr-len i) mincol)
  906.            (format:out-fill i padchar)))
  907.       (if pad-left
  908.           (format:out-str objstr))))))
  909.  
  910. (define (format:out-num-padded modifier number pars radix)
  911.   (if (not (integer? number)) (format:error "argument not an integer"))
  912.   (let ((numstr (number->string number radix)))
  913.     (if (and format:radix-pref (not (= radix 10)))
  914.     (set! numstr (substring numstr 2 (string-length numstr))))
  915.     (if (and (null? pars) (not modifier))
  916.     (format:out-str numstr)
  917.     (let ((l (length pars))
  918.           (numstr-len (string-length numstr)))
  919.       (let ((mincol (format:par pars l 0 #f "mincol"))
  920.         (padchar (integer->char
  921.               (format:par pars l 1 format:space-ch #f)))
  922.         (commachar (integer->char
  923.                 (format:par pars l 2 (char->integer #\,) #f)))
  924.         (commawidth (format:par pars l 3 3 "commawidth")))
  925.         (if mincol
  926.         (let ((numlen numstr-len)) ; calc. the output len of number
  927.           (if (and (memq modifier '(at colon-at)) (> number 0))
  928.               (set! numlen (+ numlen 1)))
  929.           (if (memq modifier '(colon colon-at))
  930.               (set! numlen (+ (quotient (- numstr-len 
  931.                            (if (< number 0) 2 1))
  932.                         commawidth)
  933.                       numlen)))
  934.           (if (> mincol numlen)
  935.               (format:out-fill (- mincol numlen) padchar))))
  936.         (if (and (memq modifier '(at colon-at))
  937.              (> number 0))
  938.         (format:out-char #\+))
  939.         (if (memq modifier '(colon colon-at)) ; insert comma character
  940.         (let ((start (remainder numstr-len commawidth))
  941.               (ns (if (< number 0) 1 0)))
  942.           (format:out-substr numstr 0 start)
  943.           (do ((i start (+ i commawidth)))
  944.               ((>= i numstr-len))
  945.             (if (> i ns)
  946.             (format:out-char commachar))
  947.             (format:out-substr numstr i (+ i commawidth))))
  948.         (format:out-str numstr)))))))
  949.  
  950. (define (format:tabulate modifier pars)
  951.   (let ((l (length pars)))
  952.     (let ((colnum (format:par pars l 0 1 "colnum"))
  953.       (colinc (format:par pars l 1 1 "colinc"))
  954.       (padch (integer->char (format:par pars l 2 format:space-ch #f))))
  955.       (case modifier
  956.     ((colon colon-at)
  957.      (format:error "unsupported modifier for ~~t"))
  958.     ((at)                ; relative tabulation
  959.      (format:out-fill
  960.       (if (= colinc 0)
  961.           colnum            ; colnum = colrel
  962.           (do ((c 0 (+ c colinc))
  963.            (col (+ format:output-col colnum)))
  964.           ((>= c col)
  965.            (- c format:output-col))))
  966.       padch))
  967.     (else                ; absolute tabulation
  968.      (format:out-fill
  969.       (cond
  970.        ((< format:output-col colnum)
  971.         (- colnum format:output-col))
  972.        ((= colinc 0)
  973.         0)
  974.        (else
  975.         (do ((c colnum (+ c colinc)))
  976.         ((>= c format:output-col)
  977.          (- c format:output-col)))))
  978.       padch))))))
  979.  
  980.  
  981. ;; roman numerals (from dorai@cs.rice.edu).
  982.  
  983. (define format:roman-alist
  984.   '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
  985.     (10 #\X) (5 #\V) (1 #\I)))
  986.  
  987. (define format:roman-boundary-values
  988.   '(100 100 10 10 1 1 #f))
  989.  
  990. (define format:num->old-roman
  991.   (lambda (n)
  992.     (if (and (integer? n) (>= n 1))
  993.     (let loop ((n n)
  994.            (romans format:roman-alist)
  995.            (s '()))
  996.       (if (null? romans) (list->string (reverse s))
  997.           (let ((roman-val (caar romans))
  998.             (roman-dgt (cadar romans)))
  999.         (do ((q (quotient n roman-val) (- q 1))
  1000.              (s s (cons roman-dgt s)))
  1001.             ((= q 0)
  1002.              (loop (remainder n roman-val)
  1003.                (cdr romans) s))))))
  1004.     (format:error "only positive integers can be romanized"))))
  1005.  
  1006. (define format:num->roman
  1007.   (lambda (n)
  1008.     (if (and (integer? n) (> n 0))
  1009.     (let loop ((n n)
  1010.            (romans format:roman-alist)
  1011.            (boundaries format:roman-boundary-values)
  1012.            (s '()))
  1013.       (if (null? romans)
  1014.           (list->string (reverse s))
  1015.           (let ((roman-val (caar romans))
  1016.             (roman-dgt (cadar romans))
  1017.             (bdry (car boundaries)))
  1018.         (let loop2 ((q (quotient n roman-val))
  1019.                 (r (remainder n roman-val))
  1020.                 (s s))
  1021.           (if (= q 0)
  1022.               (if (and bdry (>= r (- roman-val bdry)))
  1023.               (loop (remainder r bdry) (cdr romans)
  1024.                 (cdr boundaries)
  1025.                 (cons roman-dgt
  1026.                   (append
  1027.                 (cdr (assv bdry romans))
  1028.                 s)))
  1029.               (loop r (cdr romans) (cdr boundaries) s))
  1030.               (loop2 (- q 1) r (cons roman-dgt s)))))))
  1031.     (format:error "only positive integers can be romanized"))))
  1032.  
  1033. ;; cardinals & ordinals (from dorai@cs.rice.edu)
  1034.  
  1035. (define format:cardinal-ones-list
  1036.   '(#f "one" "two" "three" "four" "five"
  1037.      "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
  1038.      "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
  1039.      "nineteen"))
  1040.  
  1041. (define format:cardinal-tens-list
  1042.   '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
  1043.      "ninety"))
  1044.  
  1045. (define format:num->cardinal999
  1046.   (lambda (n)
  1047.     ;this procedure is inspired by the Bruno Haible's CLisp
  1048.     ;function format-small-cardinal, which converts numbers
  1049.     ;in the range 1 to 999, and is used for converting each
  1050.     ;thousand-block in a larger number
  1051.     (let* ((hundreds (quotient n 100))
  1052.        (tens+ones (remainder n 100))
  1053.        (tens (quotient tens+ones 10))
  1054.        (ones (remainder tens+ones 10)))
  1055.       (append
  1056.     (if (> hundreds 0)
  1057.         (append
  1058.           (string->list
  1059.         (list-ref format:cardinal-ones-list hundreds))
  1060.           (string->list" hundred")
  1061.           (if (> tens+ones 0) '(#\space) '()))
  1062.         '())
  1063.     (if (< tens+ones 20)
  1064.         (if (> tens+ones 0)
  1065.         (string->list
  1066.           (list-ref format:cardinal-ones-list tens+ones))
  1067.         '())
  1068.         (append
  1069.           (string->list
  1070.         (list-ref format:cardinal-tens-list tens))
  1071.           (if (> ones 0)
  1072.           (cons #\-
  1073.             (string->list
  1074.               (list-ref format:cardinal-ones-list ones))))))))))
  1075.  
  1076. (define format:cardinal-thousand-block-list
  1077.   '("" " thousand" " million" " billion" " trillion" " quadrillion"
  1078.      " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  1079.      " decillion" " undecillion" " duodecillion" " tredecillion"
  1080.      " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
  1081.      " octodecillion" " novemdecillion" " vigintillion"))
  1082.  
  1083. (define format:num->cardinal
  1084.   (lambda (n)
  1085.     (cond ((not (integer? n))
  1086.        (format:error
  1087.          "only integers can be converted to English cardinals"))
  1088.       ((= n 0) "zero")
  1089.       ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
  1090.       (else
  1091.         (let ((power3-word-limit
  1092.             (length format:cardinal-thousand-block-list)))
  1093.           (let loop ((n n)
  1094.              (power3 0)
  1095.              (s '()))
  1096.         (if (= n 0)
  1097.             (list->string s)
  1098.             (let ((n-before-block (quotient n 1000))
  1099.               (n-after-block (remainder n 1000)))
  1100.               (loop n-before-block
  1101.             (+ power3 1)
  1102.             (if (> n-after-block 0)
  1103.                 (append
  1104.                   (if (> n-before-block 0)
  1105.                   (string->list ", ") '())
  1106.                   (format:num->cardinal999 n-after-block)
  1107.                   (if (< power3 power3-word-limit)
  1108.                   (string->list
  1109.                     (list-ref
  1110.                      format:cardinal-thousand-block-list
  1111.                      power3))
  1112.                   (append
  1113.                     (string->list " times ten to the ")
  1114.                     (string->list
  1115.                       (format:num->ordinal
  1116.                     (* power3 3)))
  1117.                     (string->list " power")))
  1118.                   s)
  1119.                 s))))))))))
  1120.  
  1121. (define format:ordinal-ones-list
  1122.   '(#f "first" "second" "third" "fourth" "fifth"
  1123.      "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
  1124.      "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
  1125.      "eighteenth" "nineteenth"))
  1126.  
  1127. (define format:ordinal-tens-list
  1128.   '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
  1129.      "seventieth" "eightieth" "ninetieth"))
  1130.  
  1131. (define format:num->ordinal
  1132.   (lambda (n)
  1133.     (cond ((not (integer? n))
  1134.        (format:error
  1135.          "only integers can be converted to English ordinals"))
  1136.       ((= n 0) "zeroth")
  1137.       ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
  1138.       (else
  1139.         (let ((hundreds (quotient n 100))
  1140.           (tens+ones (remainder n 100)))
  1141.           (string-append
  1142.         (if (> hundreds 0)
  1143.             (string-append
  1144.               (format:num->cardinal (* hundreds 100))
  1145.               (if (= tens+ones 0) "th" " "))
  1146.             "")
  1147.         (if (= tens+ones 0) ""
  1148.             (if (< tens+ones 20)
  1149.             (list-ref format:ordinal-ones-list tens+ones)
  1150.             (let ((tens (quotient tens+ones 10))
  1151.                   (ones (remainder tens+ones 10)))
  1152.               (if (= ones 0)
  1153.                   (list-ref format:ordinal-tens-list tens)
  1154.                   (string-append
  1155.                 (list-ref format:cardinal-tens-list tens)
  1156.                 "-"
  1157.                 (list-ref format:ordinal-ones-list ones))))
  1158.             ))))))))
  1159.  
  1160. ;; format fixed flonums (~F)
  1161.  
  1162. (define (format:out-fixed modifier number pars)
  1163.   (if (not (or (number? number) (string? number)))
  1164.       (format:error "argument is not a number or a number string"))
  1165.  
  1166.   (let ((l (length pars)))
  1167.     (let ((width (format:par pars l 0 #f "width"))
  1168.       (digits (format:par pars l 1 #f "digits"))
  1169.       (scale (format:par pars l 2 0 #f))
  1170.       (overch (format:par pars l 3 #f #f))
  1171.       (padch (format:par pars l 4 format:space-ch #f)))
  1172.  
  1173.     (if digits
  1174.  
  1175.     (begin                ; fixed precision
  1176.       (format:parse-float 
  1177.        (if (string? number) number (number->string number)) #t scale)
  1178.       (if (<= (- format:fn-len format:fn-dot) digits)
  1179.           (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1180.           (format:fn-round digits))
  1181.       (if width
  1182.           (let ((numlen (+ format:fn-len 1)))
  1183.         (if (or (not format:fn-pos?) (eq? modifier 'at))
  1184.             (set! numlen (+ numlen 1)))
  1185.         (if (and (= format:fn-dot 0) (> width (+ digits 1)))
  1186.             (set! numlen (+ numlen 1)))
  1187.         (if (< numlen width)
  1188.             (format:out-fill (- width numlen) (integer->char padch)))
  1189.         (if (and overch (> numlen width))
  1190.             (format:out-fill width (integer->char overch))
  1191.             (format:fn-out modifier (> width (+ digits 1)))))
  1192.           (format:fn-out modifier #t)))
  1193.  
  1194.     (begin                ; free precision
  1195.       (format:parse-float
  1196.        (if (string? number) number (number->string number)) #t scale)
  1197.       (format:fn-strip)
  1198.       (if width
  1199.           (let ((numlen (+ format:fn-len 1)))
  1200.         (if (or (not format:fn-pos?) (eq? modifier 'at))
  1201.             (set! numlen (+ numlen 1)))
  1202.         (if (= format:fn-dot 0)
  1203.             (set! numlen (+ numlen 1)))
  1204.         (if (< numlen width)
  1205.             (format:out-fill (- width numlen) (integer->char padch)))
  1206.         (if (> numlen width)    ; adjust precision if possible
  1207.             (let ((dot-index (- numlen
  1208.                     (- format:fn-len format:fn-dot))))
  1209.               (if (> dot-index width)
  1210.               (if overch    ; numstr too big for required width
  1211.                   (format:out-fill width (integer->char overch))
  1212.                   (format:fn-out modifier #t))
  1213.               (begin
  1214.                 (format:fn-round (- width dot-index))
  1215.                 (format:fn-out modifier #t))))
  1216.             (format:fn-out modifier #t)))
  1217.           (format:fn-out modifier #t)))))))
  1218.  
  1219. ;; format exponential flonums (~E)
  1220.  
  1221. (define (format:out-expon modifier number pars)
  1222.   (if (not (or (number? number) (string? number)))
  1223.       (format:error "argument is not a number"))
  1224.  
  1225.   (let ((l (length pars)))
  1226.     (let ((width (format:par pars l 0 #f "width"))
  1227.       (digits (format:par pars l 1 #f "digits"))
  1228.       (edigits (format:par pars l 2 #f "exponent digits"))
  1229.       (scale (format:par pars l 3 1 #f))
  1230.       (overch (format:par pars l 4 #f #f))
  1231.       (padch (format:par pars l 5 format:space-ch #f))
  1232.       (expch (format:par pars l 6 #f #f)))
  1233.      
  1234.     (if digits                ; fixed precision
  1235.  
  1236.     (let ((digits (if (> scale 0)
  1237.               (if (< scale (+ digits 2))
  1238.                   (+ (- digits scale) 1)
  1239.                   0)
  1240.               digits)))
  1241.       (format:parse-float 
  1242.        (if (string? number) number (number->string number)) #f scale)
  1243.       (if (<= (- format:fn-len format:fn-dot) digits)
  1244.           (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1245.           (format:fn-round digits))
  1246.       (if width
  1247.           (if (and edigits overch (> format:en-len edigits))
  1248.           (format:out-fill width (integer->char overch))
  1249.           (let ((numlen (+ format:fn-len 3))) ; .E+
  1250.             (if (or (not format:fn-pos?) (eq? modifier 'at))
  1251.             (set! numlen (+ numlen 1)))
  1252.             (if (and (= format:fn-dot 0) (> width (+ digits 1)))
  1253.             (set! numlen (+ numlen 1)))    
  1254.             (set! numlen
  1255.               (+ numlen 
  1256.                  (if (and edigits (>= edigits format:en-len))
  1257.                  edigits 
  1258.                  format:en-len)))
  1259.             (if (< numlen width)
  1260.             (format:out-fill (- width numlen)
  1261.                      (integer->char padch)))
  1262.             (if (and overch (> numlen width))
  1263.             (format:out-fill width (integer->char overch))
  1264.             (begin
  1265.               (format:fn-out modifier (> width (- numlen 1)))
  1266.               (format:en-out edigits expch)))))
  1267.           (begin
  1268.         (format:fn-out modifier #t)
  1269.         (format:en-out edigits expch))))
  1270.  
  1271.     (begin                ; free precision
  1272.       (format:parse-float
  1273.        (if (string? number) number (number->string number)) #f scale)
  1274.       (format:fn-strip)
  1275.       (if width
  1276.           (if (and edigits overch (> format:en-len edigits))
  1277.           (format:out-fill width (integer->char overch))
  1278.           (let ((numlen (+ format:fn-len 3))) ; .E+
  1279.             (if (or (not format:fn-pos?) (eq? modifier 'at))
  1280.             (set! numlen (+ numlen 1)))
  1281.             (if (= format:fn-dot 0)
  1282.             (set! numlen (+ numlen 1)))
  1283.             (set! numlen
  1284.               (+ numlen
  1285.                  (if (and edigits (>= edigits format:en-len))
  1286.                  edigits 
  1287.                  format:en-len)))
  1288.             (if (< numlen width)
  1289.             (format:out-fill (- width numlen)
  1290.                      (integer->char padch)))
  1291.             (if (> numlen width) ; adjust precision if possible
  1292.             (let ((f (- format:fn-len format:fn-dot))) ; fract len
  1293.               (if (> (- numlen f) width)
  1294.                   (if overch ; numstr too big for required width
  1295.                   (format:out-fill width 
  1296.                            (integer->char overch))
  1297.                   (begin
  1298.                     (format:fn-out modifier #t)
  1299.                     (format:en-out edigits expch)))
  1300.                   (begin
  1301.                 (format:fn-round (+ (- f numlen) width))
  1302.                 (format:fn-out modifier #t)
  1303.                 (format:en-out edigits expch))))
  1304.             (begin
  1305.               (format:fn-out modifier #t)
  1306.               (format:en-out edigits expch)))))
  1307.           (begin
  1308.         (format:fn-out modifier #t)
  1309.         (format:en-out edigits expch))))))))
  1310.     
  1311. ;; format general flonums (~G)
  1312.  
  1313. (define (format:out-general modifier number pars)
  1314.   (if (not (or (number? number) (string? number)))
  1315.       (format:error "argument is not a number or a number string"))
  1316.  
  1317.   (let ((l (length pars)))
  1318.     (let ((width (if (> l 0) (list-ref pars 0) #f))
  1319.       (digits (if (> l 1) (list-ref pars 1) #f))
  1320.       (edigits (if (> l 2) (list-ref pars 2) #f))
  1321.       (overch (if (> l 4) (list-ref pars 4) #f))
  1322.       (padch (if (> l 5) (list-ref pars 5) #f)))
  1323.     (format:parse-float
  1324.      (if (string? number) number (number->string number)) #t 0)
  1325.     (format:fn-strip)
  1326.     (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
  1327.        (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
  1328.        (n (if (= format:fn-dot 0)    ; number less than (abs 1.0) ?
  1329.           (- (format:fn-zlead))
  1330.           format:fn-dot))
  1331.        (d (if digits
  1332.           digits
  1333.           (max format:fn-len (min n 7)))) ; q = format:fn-len
  1334.        (dd (- d n)))
  1335.       (if (<= 0 dd d)
  1336.       (begin
  1337.         (format:out-fixed modifier number (list ww dd #f overch padch))
  1338.         (format:out-fill ee #\space)) ;~@T not implemented yet
  1339.       (format:out-expon modifier number pars))))))
  1340.  
  1341. ;; format dollar flonums (~$)
  1342.  
  1343. (define (format:out-dollar modifier number pars)
  1344.   (if (not (or (number? number) (string? number)))
  1345.       (format:error "argument is not a number or a number string"))
  1346.  
  1347.   (let ((l (length pars)))
  1348.     (let ((digits (format:par pars l 0 2 "digits"))
  1349.       (mindig (format:par pars l 1 1 "mindig"))
  1350.       (width (format:par pars l 2 0 "width"))
  1351.       (padch (format:par pars l 3 format:space-ch #f)))
  1352.  
  1353.     (format:parse-float
  1354.      (if (string? number) number (number->string number)) #t 0)
  1355.     (if (<= (- format:fn-len format:fn-dot) digits)
  1356.     (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1357.     (format:fn-round digits))
  1358.     (let ((numlen (+ format:fn-len 1)))
  1359.       (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
  1360.       (set! numlen (+ numlen 1)))
  1361.       (if (and mindig (> mindig format:fn-dot))
  1362.       (set! numlen (+ numlen (- mindig format:fn-dot))))
  1363.       (if (and (= format:fn-dot 0) (not mindig))
  1364.       (set! numlen (+ numlen 1)))
  1365.       (if (< numlen width)
  1366.       (case modifier
  1367.         ((colon)
  1368.          (if (not format:fn-pos?)
  1369.          (format:out-char #\-))
  1370.          (format:out-fill (- width numlen) (integer->char padch)))
  1371.         ((at)
  1372.          (format:out-fill (- width numlen) (integer->char padch))
  1373.          (format:out-char (if format:fn-pos? #\+ #\-)))
  1374.         ((colon-at)
  1375.          (format:out-char (if format:fn-pos? #\+ #\-))
  1376.          (format:out-fill (- width numlen) (integer->char padch)))
  1377.         (else
  1378.          (format:out-fill (- width numlen) (integer->char padch))
  1379.          (if (not format:fn-pos?)
  1380.          (format:out-char #\-))))
  1381.       (if format:fn-pos?
  1382.           (if (memq modifier '(at colon-at)) (format:out-char #\+))
  1383.           (format:out-char #\-))))
  1384.     (if (and mindig (> mindig format:fn-dot))
  1385.     (format:out-fill (- mindig format:fn-dot) #\0))
  1386.     (if (and (= format:fn-dot 0) (not mindig))
  1387.     (format:out-char #\0))
  1388.     (format:out-substr format:fn-str 0 format:fn-dot)
  1389.     (format:out-char #\.)
  1390.     (format:out-substr format:fn-str format:fn-dot format:fn-len))))
  1391.  
  1392. ; the flonum buffers
  1393.  
  1394. (define format:fn-max 200)        ; max. number of number digits
  1395. (define format:fn-str (make-string format:fn-max)) ; number buffer
  1396. (define format:fn-len 0)        ; digit length of number
  1397. (define format:fn-dot #f)        ; dot position of number
  1398. (define format:fn-pos? #t)        ; number positive?
  1399. (define format:en-max 10)        ; max. number of exponent digits
  1400. (define format:en-str (make-string format:en-max)) ; exponent buffer
  1401. (define format:en-len 0)        ; digit length of exponent
  1402. (define format:en-pos? #t)        ; exponent positive?
  1403.  
  1404. (define (format:parse-float num-str fixed? scale)
  1405.   (set! format:fn-pos? #t)
  1406.   (set! format:fn-len 0)
  1407.   (set! format:fn-dot #f)
  1408.   (set! format:en-pos? #t)
  1409.   (set! format:en-len 0)
  1410.   (do ((i 0 (+ i 1))
  1411.        (left-zeros 0)
  1412.        (mantissa? #t)
  1413.        (all-zeros? #t)
  1414.        (num-len (string-length num-str))
  1415.        (c #f))            ; current exam. character in num-str
  1416.       ((= i num-len)
  1417.        (if (not format:fn-dot)
  1418.        (set! format:fn-dot format:fn-len))
  1419.  
  1420.        (if all-zeros?
  1421.        (begin
  1422.          (set! left-zeros 0)
  1423.          (set! format:fn-dot 0)
  1424.          (set! format:fn-len 1)))
  1425.  
  1426.        ;; now format the parsed values according to format's need
  1427.  
  1428.        (if fixed?
  1429.  
  1430.        (begin            ; fixed format m.nnn or .nnn
  1431.          (if (and (> left-zeros 0) (> format:fn-dot 0))
  1432.          (if (> format:fn-dot left-zeros) 
  1433.              (begin        ; norm 0{0}nn.mm to nn.mm
  1434.                (format:fn-shiftleft left-zeros)
  1435.                (set! left-zeros 0)
  1436.                (set! format:fn-dot (- format:fn-dot left-zeros)))
  1437.              (begin        ; normalize 0{0}.nnn to .nnn
  1438.                (format:fn-shiftleft format:fn-dot)
  1439.                (set! left-zeros (- left-zeros format:fn-dot))
  1440.                (set! format:fn-dot 0))))
  1441.          (if (or (not (= scale 0)) (> format:en-len 0))
  1442.          (let ((shift (+ scale (format:en-int))))
  1443.            (cond
  1444.             (all-zeros? #t)
  1445.             ((> (+ format:fn-dot shift) format:fn-len)
  1446.              (format:fn-zfill
  1447.               #f (- shift (- format:fn-len format:fn-dot)))
  1448.              (set! format:fn-dot format:fn-len))
  1449.             ((< (+ format:fn-dot shift) 0)
  1450.              (format:fn-zfill #t (- (- shift) format:fn-dot))
  1451.              (set! format:fn-dot 0))
  1452.             (else
  1453.              (if (> left-zeros 0)
  1454.              (if (<= left-zeros shift) ; shift always > 0 here
  1455.                  (format:fn-shiftleft shift) ; shift out 0s
  1456.                  (begin
  1457.                    (format:fn-shiftleft left-zeros)
  1458.                    (set! format:fn-dot (- shift left-zeros))))
  1459.              (set! format:fn-dot (+ format:fn-dot shift))))))))
  1460.  
  1461.        (let ((negexp        ; expon format m.nnnEee
  1462.           (if (> left-zeros 0)
  1463.               (- left-zeros format:fn-dot -1)
  1464.               (if (= format:fn-dot 0) 1 0))))
  1465.          (if (> left-zeros 0)
  1466.          (begin            ; normalize 0{0}.nnn to n.nn
  1467.            (format:fn-shiftleft left-zeros)
  1468.            (set! format:fn-dot 1))
  1469.          (if (= format:fn-dot 0)
  1470.              (set! format:fn-dot 1)))
  1471.          (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
  1472.                    negexp))
  1473.          (cond 
  1474.           (all-zeros?
  1475.            (format:en-set 0)
  1476.            (set! format:fn-dot 1))
  1477.           ((< scale 0)        ; leading zero
  1478.            (format:fn-zfill #t (- scale))
  1479.            (set! format:fn-dot 0))
  1480.           ((> scale format:fn-dot)
  1481.            (format:fn-zfill #f (- scale format:fn-dot))
  1482.            (set! format:fn-dot scale))
  1483.           (else
  1484.            (set! format:fn-dot scale)))))
  1485.        #t)
  1486.  
  1487.     ;; do body      
  1488.     (set! c (string-ref num-str i))    ; parse the output of number->string
  1489.     (cond                ; which can be any valid number
  1490.      ((char-numeric? c)            ; representation of R4RS except 
  1491.       (if mantissa?            ; complex numbers
  1492.       (begin
  1493.         (if (char=? c #\0)
  1494.         (if all-zeros?
  1495.             (set! left-zeros (+ left-zeros 1)))
  1496.         (begin
  1497.           (set! all-zeros? #f)))
  1498.         (string-set! format:fn-str format:fn-len c)
  1499.         (set! format:fn-len (+ format:fn-len 1)))
  1500.       (begin
  1501.         (string-set! format:en-str format:en-len c)
  1502.         (set! format:en-len (+ format:en-len 1)))))
  1503.      ((or (char=? c #\-) (char=? c #\+))
  1504.       (if mantissa?
  1505.       (set! format:fn-pos? (char=? c #\+))
  1506.       (set! format:en-pos? (char=? c #\+))))
  1507.      ((char=? c #\.)
  1508.       (set! format:fn-dot format:fn-len))
  1509.      ((char=? c #\e)
  1510.       (set! mantissa? #f))
  1511.      ((char=? c #\E)
  1512.       (set! mantissa? #f))
  1513.      ((char-whitespace? c) #t)
  1514.      ((char=? c #\d) #t)        ; decimal radix prefix
  1515.      ((char=? c #\#) #t)
  1516.      (else
  1517.       (format:error "illegal character `~c' in number->string" c)))))
  1518.  
  1519. (define (format:en-int)            ; convert exponent string to integer
  1520.   (if (= format:en-len 0)
  1521.       0
  1522.       (do ((i 0 (+ i 1))
  1523.        (n 0))
  1524.       ((= i format:en-len) 
  1525.        (if format:en-pos?
  1526.            n
  1527.            (- n)))
  1528.     (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
  1529.                    format:zero-ch))))))
  1530.  
  1531. (define (format:en-set en)        ; set exponent string number
  1532.   (set! format:en-len 0)
  1533.   (set! format:en-pos? (>= en 0))
  1534.   (let ((en-str (number->string en)))
  1535.     (do ((i 0 (+ i 1))
  1536.      (en-len (string-length en-str))
  1537.      (c #f))
  1538.     ((= i en-len))
  1539.       (set! c (string-ref en-str i))
  1540.       (if (char-numeric? c)
  1541.       (begin
  1542.         (string-set! format:en-str format:en-len c)
  1543.         (set! format:en-len (+ format:en-len 1)))))))
  1544.  
  1545. (define (format:fn-zfill left? n)    ; fill current number string with 0s
  1546.   (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
  1547.       (format:error "number is too long to format (enlarge format:fn-max)"))
  1548.   (set! format:fn-len (+ format:fn-len n))
  1549.   (if left?
  1550.       (do ((i format:fn-len (- i 1)))    ; fill n 0s to left
  1551.       ((< i 0))
  1552.     (string-set! format:fn-str i
  1553.              (if (< i n)
  1554.              #\0
  1555.              (string-ref format:fn-str (- i n)))))
  1556.       (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
  1557.       ((= i format:fn-len))
  1558.     (string-set! format:fn-str i #\0))))
  1559.  
  1560. (define (format:fn-shiftleft n)        ; shift left current number n positions
  1561.   (if (> n format:fn-len)
  1562.       (format:error "internal error in format:fn-shiftleft (~d,~d)"
  1563.             n format:fn-len))
  1564.   (do ((i n (+ i 1)))
  1565.       ((= i format:fn-len)
  1566.        (set! format:fn-len (- format:fn-len n)))
  1567.     (string-set! format:fn-str (- i n) (string-ref format:fn-str i))))
  1568.  
  1569. (define (format:fn-round digits)    ; round format:fn-str
  1570.   (set! digits (+ digits format:fn-dot))
  1571.   (do ((i digits (- i 1))        ; "099",2 -> "10"
  1572.        (c 5))                ; "023",2 -> "02"
  1573.       ((or (= c 0) (< i 0))        ; "999",2 -> "100"
  1574.        (if (= c 1)            ; "005",2 -> "01"
  1575.        (begin            ; carry overflow
  1576.          (set! format:fn-len digits)
  1577.          (format:fn-zfill #t 1)    ; add a 1 before fn-str
  1578.          (string-set! format:fn-str 0 #\1)
  1579.          (set! format:fn-dot (+ format:fn-dot 1)))
  1580.        (set! format:fn-len digits)))
  1581.     (set! c (+ (- (char->integer (string-ref format:fn-str i))
  1582.           format:zero-ch) c))
  1583.     (string-set! format:fn-str i (integer->char
  1584.                   (if (< c 10) 
  1585.                       (+ c format:zero-ch)
  1586.                       (+ (- c 10) format:zero-ch))))
  1587.     (set! c (if (< c 10) 0 1))))
  1588.  
  1589. (define (format:fn-out modifier add-leading-zero?)
  1590.   (if format:fn-pos?
  1591.       (if (eq? modifier 'at) 
  1592.       (format:out-char #\+))
  1593.       (format:out-char #\-))
  1594.   (if (= format:fn-dot 0)
  1595.       (if add-leading-zero?
  1596.       (format:out-char #\0))
  1597.       (format:out-substr format:fn-str 0 format:fn-dot))
  1598.   (format:out-char #\.)
  1599.   (format:out-substr format:fn-str format:fn-dot format:fn-len))
  1600.  
  1601. (define (format:en-out edigits expch)
  1602.   (format:out-char (if expch (integer->char expch) format:expch))
  1603.   (format:out-char (if format:en-pos? #\+ #\-))
  1604.   (if edigits 
  1605.       (if (< format:en-len edigits)
  1606.       (format:out-fill (- edigits format:en-len) #\0)))
  1607.   (format:out-substr format:en-str 0 format:en-len))
  1608.  
  1609. (define (format:fn-strip)        ; strip trailing zeros but one
  1610.   (string-set! format:fn-str format:fn-len #\0)
  1611.   (do ((i format:fn-len (- i 1)))
  1612.       ((or (not (char=? (string-ref format:fn-str i) #\0))
  1613.        (<= i format:fn-dot))
  1614.        (set! format:fn-len (+ i 1)))))
  1615.  
  1616. (define (format:fn-zlead)        ; count leading zeros
  1617.   (do ((i 0 (+ i 1)))
  1618.       ((or (= i format:fn-len)
  1619.        (not (char=? (string-ref format:fn-str i) #\0)))
  1620.        (if (= i format:fn-len)        ; found a real zero
  1621.        0
  1622.        i))))
  1623.  
  1624.  
  1625. ;;; some global functions not found in SLIB
  1626.  
  1627. ;; string-index finds the index of the first occurence of the character `c'
  1628. ;; in the string `s'; it returns #f if there is no such character in `s'.
  1629.  
  1630. (define (string-index s c)
  1631.   (let ((slen-1 (- (string-length s) 1)))
  1632.     (let loop ((i 0))
  1633.       (cond
  1634.        ((char=? c (string-ref s i)) i)
  1635.        ((= i slen-1) #f)
  1636.        (else (loop (+ i 1)))))))
  1637.  
  1638. (define (string-capitalize-first str)    ; "hello" -> "Hello"
  1639.   (let ((cap-str (string-copy str))    ; "hELLO" -> "Hello"
  1640.     (non-first-alpha #f)        ; "*hello" -> "*Hello"
  1641.     (str-len (string-length str)))    ; "hello you" -> "Hello you"
  1642.     (do ((i 0 (+ i 1)))
  1643.     ((= i str-len) cap-str)
  1644.       (let ((c (string-ref str i)))
  1645.     (if (char-alphabetic? c)
  1646.         (if non-first-alpha
  1647.         (string-set! cap-str i (char-downcase c))
  1648.         (begin
  1649.           (set! non-first-alpha #t)
  1650.           (string-set! cap-str i (char-upcase c)))))))))
  1651.  
  1652. (define (list-head l k)
  1653.   (if (= k 0)
  1654.       '()
  1655.       (cons (car l) (list-head (cdr l) (- k 1)))))
  1656.  
  1657.  
  1658. ;; Aborts the program when a formatting error occures. This is a null
  1659. ;; argument closure to jump to the interpreters toplevel continuation.
  1660.  
  1661. (define format:abort (lambda () (slib:error "error in format")))
  1662.  
  1663. (define format format:format)
  1664.  
  1665. ;; If this is not possible then a continuation is used to recover
  1666. ;; properly from a format error. In this case format returns #f.
  1667.  
  1668. ;(define format:abort
  1669. ;  (lambda () (format:error-continuation #f)))
  1670.  
  1671. ;(define format
  1672. ;  (lambda args                ; wraps format:format with an error
  1673. ;    (call-with-current-continuation    ; continuation
  1674. ;     (lambda (cont)
  1675. ;       (set! format:error-continuation cont)
  1676. ;       (apply format:format args)))))
  1677.  
  1678. ;eof
  1679.